perm filename WRIFUN.F4[FUN,LCS] blob
sn#519429 filedate 1980-06-28 generic text, type T, neo UTF8
00100 SUBROUTINE WRIFUN
00200 COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
00300 1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
00400 COMMON FUNC(512),F2(512),K,I
00500 DATA ARY/'ARRAY'/,R999/999.0/,MX/' '/
00600 24 FORMAT(' TYPE FUNCTION NAME '$)
00700 34 FORMAT(' PRINT "',A3,'-";'/,A5,'(',A5,');',A5)
00800 35 FORMAT(1XA5,'IN FILE "',A5,'.FUN"'/)
00900 37 FORMAT(8F10.4)
01000 39 FORMAT(A5,10(A1,A3))
01100 391 FORMAT(2A3)
01200 390 FORMAT(A1)
01300 43 FORMAT(' NO ROOM IN FILE "',A5,'.FUN"')
01400 44 FORMAT(' FUNCTIONS ALREADY IN FILE - ',A5)
01500 45 FORMAT('(512);')
01600
01700 IF(IDEL.NE.0)GO TO 292
01800 C FOR DELETIONS
01900 IF(Z.EQ.'N')GO TO 912
02000 IF(FLNM.EQ.FLNM1.AND.FLNM.NE.0)GO TO 1922
02100 C JUMP IF THAT FILE IS NOW IN CORE
02200 FLNM1=0
02300 C ↑↑↑↑↑↑ TO GUARD AGAINST CONFUSION IN BACKUPS.
02400 CALL READ1
02500 1922 IF(Z.EQ.'N')GO TO 912
02600 CC COLGATE 7/741922 TYPE 44,FLNM
02700 TYPE 44,FLNM
02800 C FUNCS. IN FILE
02900 TYPE 39,MX,B
03000 912 TYPE 24
03100 ACCEPT 390,FNUM
03200 CALL LO2UP(FNUM)
03300 IF(FNUM.EQ.'B')GO TO 9
03400 C FOR BACKUP
03500 IF(FNUM.EQ.'X')GO TO 9
03600 IF(FNUM.EQ.' ')GO TO 1922
03700 REREAD 391,FNUM,K
03800 CALL LO2UP(FNUM)
03900 CALL LO2UP(K)
04000 IF(K.EQ.' ')GO TO 913
04100 TYPE 914
04200 GO TO 912
04300 914 FORMAT(' **** NO MORE THAN 3 CHARS. IN FUNCTION NAME ***')
04400 913 IF(Z.EQ.'N')GO TO 911
04500 IF(Z.NE.-1)GO TO 90
04600 C JUMP IF .NE. 'RENAME'
04700 C 7/74 COLGATE
04800 DO 30 K=1,LX-1
04900 IF(K.EQ.JX.OR.FN(K).NE.FNUM)GO TO 30
05000 TYPE 31
05100 CALL EXIT
05200 9 TYPE 99
05300 IF(FNUM.EQ.'X')GO TO 912
05400 RETURN
05500 99 FORMAT(' DON''T USE X FOR NAME, B=BACKUP'/)
05600 31 FORMAT(/' FUNC NAME IN USE!')
05700 30 CONTINUE
05800 B(2,JX)=FNUM
05900 FN(JX)=FNUM
06000 LX=LX-1
06100 GO TO 1906
06200 90 IF(FLNM.EQ.FLNM1)GO TO 1090
06300 FNUM1=0
06400 LX=0
06500 C TO PUT NEW FUNC IN OLD FILE
06600 CALL READER
06700 1090 JX=0
06800 DO 20 K=1,LX-1
06900 IF(FNUM.NE.FN(K))GO TO 20
07000 JX=K
07100 LX=LX-1
07200 GO TO 21
07300 20 CONTINUE
07400 210 JX=LX
07500 C JX=LX IF FNUM WAS NOT FOUND
07600 IF(JX.GT.10)GO TO 193
07700 21 FN(JX)=FNUM
07800 X='SEG'
07900 IF(J.EQ.4)X='SYNTH'
08000 XA(JX)=X
08100 CALL STORE(JX)
08200 IF(J.EQ.2)GO TO 1192
08300 AA(1,KT,JX)=999
08400 GO TO 192
08500 1192 IF(A(KT-1,2).EQ.100)GO TO 192
08600 C JUMP IF NO SMOOTHING
08700 DO 2192 K=1,512
08800 2192 AA(K,KT,JX)=FUNC(K)
08900
09000 192 IF(JX.NE.1)B(1,JX)=','
09100 B(2,JX)=FNUM
09200 GO TO 1906
09300 193 TYPE 43,FLNM
09400 C NO ROOM IN FILE.
09500 RETURN
09600 C NEW FILE
09700 911 LX=1
09800 DO 94 K=1,20
09900 94 B(K,1)=' '
10000 GO TO 210
10100 C CLEARS B FOR NEW, SINGLE ITEM.
10200 292 IF(IDEL.EQ.10)GO TO 932
10300 DO 931 K=IDEL,LX-1
10400 931 B(2,K)=B(2,K+1)
10500 932 B(1,LX)=' '
10600 B(2,LX)=' '
10700 1906 REWIND 1
10800 IF(Z.EQ.'N'.OR.IDEL.GT.0)GO TO 22
10900 DO 25 K=1,LX
11000 IF(K.GT.1.AND.B(1,K).NE.',')GO TO 26
11100 X=B(2,K)
11200 IF(X.NE.' '.AND.X.EQ.FN(K))GO TO 25
11300 26 TYPE 23
11400 C LET'S HOPE CHANGE BELOW 69 NOW MAKES THIS UNNECESSARY.
11500 RETURN
11600 23 FORMAT(/' CONFUSION IN THIS FILE. TRY ANOTHER! '/)
11700 25 CONTINUE
11800 22 CALL FORNAM(FLNM,'FUN')
11900 C WRITES FILE WITH EXTENSION .FUN
12000 CF22 CALL OFILE(1,FLNM)
12100 CC NOT YET! 22 CALL OFLE(1,FLNM,'.FUN')
12200 C COLGATE OFILE REPLACEMENT. ALL FUNC FILES WILL BE '.FUN'.
12500
12600 WRITE(1,39),ARY,B
12700 WRITE(1,45)
12800 69 NX=0
12900 IF(IDEL.EQ.0)GO TO 1905
13000 FLNM1=0
13100 FLNM=0
13200 C WIPES OUT 1ST FILE NAME SO THAT DATA ALWAYS IS READ FROM DSK AFTER A DEL.
13300 1905 IF(NX.EQ.LX)GO TO 904
13400 C LX=TOTAL # OF FUNCS
13500 NX=NX+1
13600 IF(IDEL.EQ.NX)GO TO 1905
13700 C SO THAT DATA MUST ALWAYS BE READ FROM DSK AFTER A DEL.
13800 1 J=4
13900 X=' 99'
14000 IF(XA(NX).NE.'SEG')GO TO 68
14100 J=2
14200 X=' '
14300 68 WRITE(1,34),FN(NX),XA(NX),FN(NX),X
14400 JX=0
14500 2905 JX=JX+1
14600 IF(J.EQ.2)GO TO 3905
14700 IF(AA(1,JX,NX).EQ.999)GO TO 5905
14800 C FOUND END OF A SYNTH
14900 WRITE(1,37),(AA(K,JX,NX),K=1,4)
15000 GO TO 2905
15100 5905 WRITE(1,37)R999
15200 GO TO 1905
15300 3905 X=AA(2,JX,NX)
15400 WRITE(1,37),AA(1,JX,NX),X
15500 IF(X.EQ.100)GO TO 1905
15600 C FOUND END OF A SEG
15700 IF(X.LT.100)GO TO 2905
15800 WRITE(1,37)(AA(K,JX+1,NX),K=1,512)
15900 GO TO 1905
16000 904 TYPE 39,MX,B
16100 IF(IDEL.EQ.0)TYPE 35,FNUM,FLNM
16200 IF(IDEL.NE.0)FLNM=0
16300 LX=LX+1
16400 C FOR RESTARTS
16500 CALL DDCLR
16600 C****** REMOVE ABOVE FOR EXPORT VERSION. USED TO CLEAR DATADISC.
16700 CALL EXIT
16800 END
16900
17000 SUBROUTINE READER
17100 COMMON/LN/LINE
17200 COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
17300 1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
17400 COMMON FUNC(512),F2(512),K,I
17500 37 FORMAT(8F)
17600 38 FORMAT(3(A5,A1))
17700 380 FORMAT(I,3(A5,A1))
17800 39 FORMAT(9A5)
17900 READ (1,39),K,K,AK
18000 C READS "(512);"
18100 C LX IS MAIN COUNTER
18200 401 LX=LX+1
18300 1 IF(LINE.EQ.0)READ(1,38,END=4401)XA(LX),Y,FN(LX),H,H
18400 IF(LINE)READ(1,380,END=4401)K,XA(LX),Y,FN(LX),H,H
18500 IF(XA(LX).GE.0)GO TO 1
18600 C TO FIND EOF AFTER COPY SCREWUPS
18700 IF(FNUM1.EQ.FN(LX))JX=LX
18800 C JX TELLS WHERE TO FIND FUNCTION TO BE LOOKED AT.
18900 C XA(LX) IS FUNC. TYPE (SEG OR SYNTH)
19000 X=0
19100 N=4
19200 IF(XA(LX).EQ.'SEG')N=2
19300 KX=0
19400 C KX IS LOCAL COUNTER
19500 1401 IF(X.EQ.100)GO TO 401
19600 KX=KX+1
19700 IF(LINE.EQ.0)READ(1,37),(AA(K,KX,LX),K=1,N)
19800 IF(LINE)READ(1,37)AK,(AA(K,KX,LX),K=1,N)
19900 IF(N.EQ.2)GO TO 2401
20000 IF(AA(1,KX,LX).EQ.999)GO TO 401
20100 C FOUND END OF A SYNTH
20200 GO TO 1401
20300 2401 X=AA(2,KX,LX)
20400 IF(X.LE.100)GO TO 1401
20500 C NEXT IS FOR SMOOTHED SEGS
20600 N=KX+1
20700 IF(LINE)GO TO 2
20800 READ(1,37)(AA(K,N,LX),K=1,512)
20900 GO TO 401
21000 370 FORMAT(9F)
21100 2 DO 3 K=1,512,8
21200 3 READ(1,370)AK,(AA(KX,N,LX),KX=K,K+7)
21300 GO TO 401
21400 4401 END
21500
21600
21700 SUBROUTINE READ1
21800 C READS FIRST LINE OF FILE ONLY
21900 COMMON/LN/LINE
22000 COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
22100 1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
22200 2151 REWIND 1
22300 CALL FORNAM(FLNM,'FUN')
22600 4 READ (1,39),X,B
23200 3 IF(X.NE.'COMME')GO TO 1
23300 TYPE 2
23400 X=-X
23500 1 LINE=0
23600 IF(X)RETURN
23700 LINE=-1
23800 C FOUND LN #S (CAN'T READ SMOOTHS 'THO)
23900 REREAD 390,LX,X,B
24000 2 FORMAT(' ***** WON''T READ "ET" FILES! *****')
24100 39 FORMAT(A5,10(A1,A3))
24300 390 FORMAT(I,A5,10(A1,A3))
24400 END
24500
24600 SUBROUTINE STORE(N)
24700 COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
24800 1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
24900 DO 3090 K=1,KT-1
25000 DO 3090 L=1,J
25100 3090 AA(L,K,N)=A(K,L)
25200 END